home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _9a766ed3737acef9c1ad9581144db8bc < prev    next >
Encoding:
Text File  |  2002-06-03  |  11.4 KB  |  438 lines
  1. package PPM::Config;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. use File::Path;
  6. require PPM::YAML;
  7.  
  8. $PPM::Config::VERSION = '3.00';
  9.  
  10. sub new {
  11.     my $class = shift;
  12.     my $self = bless { }, ref($class) || $class;
  13.     my $file = shift;
  14.     $self->{DATA} = {};
  15.     if (defined $file) {
  16.     $self->loadfile($file, 'load');
  17.     $self->setfile($file);
  18.     $self->setsave;
  19.     }
  20.     return $self;
  21. }
  22.  
  23. sub config {
  24.     my $o = shift;
  25.     return wantarray ? %{$o->{DATA}} : $o->{DATA};
  26. }
  27.  
  28. sub loadfile {
  29.     my $o = shift;
  30.     my $file = shift;
  31.     my $action = shift;
  32.     print "DEBUG: Loading file: $file.\n" if $ENV{PPM3_CONFIG_DEBUG};
  33.     open(FILE, "< $file")        || die "can't read $file: $!";
  34.     my $str = do { local $/; <FILE> };
  35.     my $dat = eval { PPM::YAML::deserialize($str) } || {};
  36.     close(FILE)                || die "can't close $file: $!";
  37.     $o->load($dat, $action);
  38.     $o;
  39. }
  40.  
  41. sub load {
  42.     my $o = shift;
  43.     my $dat = shift;
  44.     my $action = shift || 'load';
  45.     if ($action eq 'load' or not exists $o->{DATA}) {
  46.     $o->{DATA} = $dat;
  47.     }
  48.     else {
  49.     $o->merge($dat);
  50.     }
  51.     $o;
  52. }
  53.  
  54. sub file { $_[0]->{file} }
  55.  
  56. sub setfile {
  57.     my $o = shift;
  58.     my $file = shift;
  59.     $o->{file} = $file;
  60.     $o;
  61. }
  62.  
  63. sub setsave {
  64.     my $o = shift;
  65.     $o->{autosave} = 1;
  66.     $o;
  67. }
  68.  
  69. sub save {
  70.     my $o = shift;
  71.     my $file = shift || $o->{file};
  72.     my $mode = (stat($file))[2] & 07777;
  73.     $mode |= 0222;      # turn on write permissions (if not already)
  74.     chmod $mode, $file; # ignore failures
  75.     open(FILE, "> $file") or do {
  76.     print STDERR <<END;
  77. Warning: save $file: $!.
  78.     => Configuration not saved.
  79. END
  80.     return;
  81.     };
  82.     my $str = PPM::YAML::serialize($o->{DATA});
  83.     print FILE $str;
  84.     close(FILE)                || die "can't close $file: $!";
  85.     $o;
  86. }
  87.  
  88. sub merge {
  89.     my $o = shift;
  90.     my $dat = shift;
  91.     _merge(\$o->{DATA}, \$dat)
  92.       if (defined $dat);
  93.     $o;
  94. }
  95.  
  96. sub DESTROY {
  97.     my $o = shift;
  98.     $o->save if $o->{autosave};
  99. }
  100.  
  101. sub _merge {
  102.     my ($old_ref, $new_ref) = @_;
  103.  
  104.     return unless defined $old_ref and defined $new_ref;
  105.  
  106.     my $r_old = ref($old_ref);
  107.     my $r_new = ref($new_ref);
  108.  
  109.     return unless $r_old eq $r_new;
  110.     
  111.     if ($r_old eq 'SCALAR') {
  112.     $$old_ref = $$new_ref;
  113.     }
  114.     elsif ($r_old eq 'REF') {
  115.     my $old = $$old_ref;
  116.     my $new = $$new_ref;
  117.     $r_old = ref($old);
  118.     $r_new = ref($new);
  119.  
  120.     return unless $r_old eq $r_new;
  121.  
  122.     if (ref($old) eq 'HASH') {
  123.         for my $key (keys %$new) {
  124.         if (exists $old->{$key} and
  125.             defined $old->{$key} and
  126.             defined $new->{$key}) {
  127.             _merge(\$old->{$key}, \$new->{$key});
  128.         }
  129.         else {
  130.             $old->{$key} = $new->{$key};
  131.         }
  132.         }
  133.     }
  134.     elsif (ref($old) eq 'ARRAY') {
  135.         for my $item (@$new) {
  136.         if (ref($item) eq '' and not grep { $item eq $_ } @$old) {
  137.             push @$old, $item;
  138.         }
  139.         elsif(ref($item)) {
  140.             push @$old, $item;
  141.         }
  142.         }
  143.     }
  144.     }
  145. }
  146.  
  147. #=============================================================================
  148. # get_conf_dirs(): return a list of directories to search for config files.
  149. #=============================================================================
  150. use constant DELIM    => $^O eq 'MSWin32' ? ';' : ':';
  151. use constant PATHSEP    => $^O eq 'MSWin32' ? '\\' : '/';
  152. use constant KEYDIR    => 'ActiveState';
  153. use constant KEYFILE    => 'ActiveState.lic';
  154. use constant CONFDIR    => 'PPM';
  155. use constant CONFIG_SUFFIX => '.cfg';
  156. use constant UNIX_SHARED_ROOT => '/usr/local/etc';
  157.  
  158. sub mymkpath {
  159.     my $path = shift;
  160.     unless (-d $path) {
  161.     mkpath($path);
  162.     die "Couldn't create directory $path: $!"
  163.       unless -d $path;
  164.     }
  165.     $path;
  166. }
  167.  
  168. sub get_license_file {
  169.     my $license_dir = licGetHomeDir();
  170.     my $lic_file = join PATHSEP, $license_dir, KEYFILE;
  171.     return $lic_file;
  172. }
  173.  
  174. BEGIN {
  175.     if ($ENV{PPM3_CONFIG_DEBUG}) {
  176.     my $shared = $ENV{PPM3_SHARED} ? '' : 'not ';
  177.     my $user   = $ENV{PPM3_USER}   ? '' : 'not ';
  178.     print <<END;
  179. DEBUG: Will ${shared}stat shared configuration files...
  180. DEBUG: Will ${user}stat user's configuration files...
  181. END
  182.     }
  183. }
  184.  
  185. sub load_config_file {
  186.     my $orig = shift;
  187.     my $mode = shift || 'rw'; # 'ro' for read-only.
  188.  
  189.     my $name = $orig . CONFIG_SUFFIX;
  190.     my $conf = PPM::Config->new;
  191.  
  192.     # Load all config files in the "configuration path"
  193.     my $treedir = eval { get_tree_conf_dir()   };
  194.     my $userdir = eval { get_user_conf_dir()   };
  195.     my $shrddir = eval { get_shared_conf_dir() };
  196.     unless (grep { defined $_ } ($userdir, $shrddir, $treedir)) {
  197.     print <<END;
  198.  
  199.     *** FATAL ERROR *** 
  200.     
  201.     Couldn't find the PPM configuration directories in either your home
  202.     directory or the shared directory. That probably means neither of the
  203.     environment variables PPM3_SHARED and PPM3_USER were set by the wrapper
  204.     program "ppm3".
  205.  
  206.     Set the environment variable PPM3_CONFIG_DEBUG to 1, then rerun PPM
  207.     to get more diagnostics about where it loaded its initial
  208.     configuration.
  209.  
  210. END
  211.     exit(1);
  212.     }
  213.     my ($treefile, $userfile, $shrdfile);
  214.     $treefile = defined $treedir ? join PATHSEP, $treedir, $name : '';
  215.     $userfile = defined $userdir ? join PATHSEP, $userdir, $name : '';
  216.     $shrdfile = defined $shrddir ? join PATHSEP, $shrddir, $name : '';
  217.     print "DEBUG: treefile='$treefile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  218.     print "DEBUG: userfile='$userfile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  219.     print "DEBUG: shrdfile='$shrdfile'\n" if $ENV{PPM3_CONFIG_DEBUG};
  220.  
  221.     # Pick the least public place to save changes.
  222.     my $saveto = $treefile ? $treefile :
  223.          $userfile ? $userfile : $shrdfile;
  224.     $conf->setfile($saveto);
  225.     $conf->setsave unless $mode eq 'ro';
  226.  
  227.     # Load the "most private" file.
  228.     return $conf->loadfile($treefile) if -f $treefile;
  229.     return $conf->loadfile($userfile) if -f $userfile;
  230.     return $conf->loadfile($shrdfile) if -f $shrdfile;
  231.  
  232.     # Neither the shared nor the user's file exists. Let's attempt to
  233.     # create a stub copy of the file, initialised to reasonable defaults.
  234.     print "DEBUG: Writing a stub config file for '$name'.\n"
  235.     if $ENV{PPM3_CONFIG_DEBUG};
  236.     eval {
  237.     # Create config dir _even_ if we're going to load the file ro.
  238.     my $stubfile = $conf->file;
  239.     local *FILE;
  240.     open (FILE, "> $stubfile") or die $!;    # caught by the eval
  241.     print FILE config_file_stub($orig);    # write stub config
  242.     close FILE or die $!;
  243.     $conf->loadfile($stubfile);
  244.     };
  245.     if ($@) {
  246.     die "Fatal error: couldn't find or create config file $name: $@";
  247.     }
  248.  
  249.     return $conf;
  250. }
  251.  
  252. # Returns the "tree" configuration directory. This is the directory used by
  253. # 'ppminst'.
  254. sub tree_conf_dir {
  255.     my $d = $ENV{PPM3_PERL_SITELIB}
  256.             || do { require Config; $Config::Config{sitelibexp} };
  257.     return "$d/ppm-conf";
  258. }
  259.  
  260. sub get_tree_conf_dir {
  261.     return mymkpath(tree_conf_dir());
  262. }
  263.  
  264. # Returns the user's configuration directory. Note: throws an exception if the
  265. # directory doesn't exist and cannot be created.
  266. sub get_user_conf_dir {
  267.     return undef unless $ENV{PPM3_USER};
  268.     return mymkpath(join PATHSEP, licGetHomeDir(), CONFDIR);
  269. }
  270.  
  271. # Returns the shared configuration directory. Note: throws no exception, but
  272. # the directory is not guaranteed to exist. Install scripts and such should be
  273. # sure to create this directory themselves.
  274. sub get_shared_conf_dir {
  275.     return undef unless $ENV{PPM3_SHARED};
  276.     return join PATHSEP, UNIX_SHARED_ROOT, KEYDIR, CONFDIR
  277.       if $^O ne 'MSWin32';
  278.  
  279.     my ($R,%R);
  280.     require Win32::TieRegistry;
  281.     Win32::TieRegistry->import(TiedHash => \%R);
  282.     bless do { $R = \%R }, "Win32::TieRegistry";
  283.     $R->Delimiter('/');
  284.     my $wkey = $R->{"HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/"};
  285.     my $xkey = $wkey->{"CurrentVersion/Explorer/Shell Folders/"};
  286.     my $shared_root = $xkey->{"/Common AppData"};
  287.     return join PATHSEP, $shared_root, KEYDIR, CONFDIR;
  288. }
  289.  
  290. sub get_conf_dirs {
  291.     my @path;
  292.     push @path, get_shared_conf_dir(), get_user_conf_dir();
  293.     @path
  294. }
  295.  
  296. #=============================================================================
  297. # licGetHomeDir(): copied and converted from the Licence_V8 code:
  298. #=============================================================================
  299. sub licGetHomeDir {
  300.     my $dir;
  301.     my ($env1, $env2);
  302.  
  303.     if ($^O eq 'MSWin32') {
  304.     $env1 = $ENV{APPDATA};
  305.     }
  306.  
  307.     unless ($env1) {
  308.     $env1 = $ENV{HOME};
  309.     }
  310.  
  311.     # On Linux & Solaris:
  312.     if ($^O ne 'MSWin32') {
  313.     unless ($env1) {
  314.         $env1 = (getpwuid $<)[7]; # Try to get $ENV{HOME} the hard way
  315.     }
  316.     $dir = sprintf("%s/.%s", $env1, KEYDIR);
  317.     }
  318.  
  319.     # On Windows:
  320.     else {
  321.     unless ($env1) {
  322.         $env1 = $ENV{USERPROFILE};
  323.     }
  324.     unless ($env1) {
  325.         $env1 = $ENV{HOMEDRIVE};
  326.         $env2 = $ENV{HOMEPATH};
  327.     }
  328.     unless ($env1) {
  329.         $env1 = $ENV{windir};
  330.     }
  331.     unless ($env1) {
  332.         die ("Couldn't find HOME / USERPROFILE / HOMEDRIVE&HOMEPATH / windir");
  333.     }
  334.     $env2 ||= "";
  335.     $dir = $env1 . $env2;
  336.     $dir =~ s|/|\\|g;
  337.  
  338.     # Win32 _stat() doesn't like trailing backslashes, except for x:\
  339.     while (length($dir) > 3 && substr($dir, -1) eq '\\') {
  340.         chop($dir);
  341.     }
  342.  
  343.     die ("Not a directory: $dir") unless -d $dir;
  344.  
  345.     $dir .= PATHSEP;
  346.     $dir .= KEYDIR;
  347.     }
  348.  
  349.     # Create it if it doesn't exist yet
  350.     return mymkpath($dir);
  351. }
  352.  
  353. sub config_file_stub {
  354.     my $name = shift;
  355.     if ($name eq 'clientlib') {
  356.     my $tmp = $ENV{TEMP} || $^O eq 'MSWin32' ? 'C:\TEMP' : '/tmp';
  357.     my $server = do {
  358.         require PPM::Compat;
  359.         PPM::Compat::repository('ppm3');
  360.     };
  361.     return <<END;
  362. downloadbytes: 16384
  363. profile_enable: 0
  364. profile_server: $server
  365. tempdir: $tmp
  366. tracefile: ppm3.log
  367. tracelvl: 0
  368. END
  369.     }
  370.     elsif ($name eq 'cmdline') {
  371.     # This is actually a little bit wrong, since there are (potentially)
  372.     # multiple frontends. Each frontend should really be responsible for
  373.     # its own configuration data. Still, I don't care all that much.
  374.     return <<'END';
  375. case-sensitivity: 0
  376. fields: name version abstract
  377. follow-install: 1
  378. force-install: 0
  379. install-verbose: 1
  380. max_history: 100
  381. page-lines: 24
  382. pager: ""
  383. prompt-context: 0
  384. prompt-slotsize: 11
  385. prompt-verbose: 0
  386. remove-verbose: 1
  387. sort-field: name
  388. upgrade-verbose: 1
  389. verbose-startup: 1
  390. END
  391.     }
  392.     elsif ($name eq 'instkey') {
  393.     my $txt = do {
  394.         require PPM::Sysinfo;
  395.         my $DATA = PPM::Sysinfo::generate_inst_key();
  396.         return PPM::YAML::serialize($DATA);
  397.     };
  398.     }
  399.     elsif ($name eq 'repositories') {
  400.     my $url_ppm2 = do {
  401.         require PPM::Compat;
  402.         PPM::Compat::repository('ppm2');
  403.     };
  404.     my $url_ppm3 = do {
  405.         require PPM::Compat;
  406.         PPM::Compat::repository('ppm3');
  407.     };
  408.     return <<END;
  409. ActiveState Package Repository: %
  410.     url: $url_ppm3
  411. ActiveState PPM2 Repository: %
  412.     url: $url_ppm2
  413. END
  414.     }
  415.     elsif ($name eq 'targets') {
  416.     # Targets.cfg is the only oddball, because there are multiple targets
  417.     # out there. What we do is this: at build time (at ActiveState) we
  418.     # write a targets.cfg file which is to be relocated at install time.
  419.     # Instead of installing it using a post-install script, ppm3-bin will
  420.     # now look for it next to the binary, and use its contents as the stub
  421.     # targets.cfg file. If the user deletes their .ActiveState/PPM
  422.     # directory, this will magically reappear.
  423.     use FindBin qw($Bin);
  424.     my $f = "$Bin/ppm3-bin.cfg";
  425.     my $txt;
  426.     if (-f $f) {
  427.         local *STUB;
  428.         open STUB, $f    or die "can't open $f: $!";
  429.         $txt = do { local $/; <STUB> };
  430.         close STUB        or die "can't close $f: $!";
  431.     }
  432.     return $txt;
  433.     }
  434.     return '';    # unrecognized file
  435. }
  436.  
  437. 1;
  438.